Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/comps/widgets/delphi10/thuicpnl/thuicpnl.pas

Pascal/Delphi Source File | 1996-06-17 | 22.5 KB | 656 lines

unit Thuicpnl;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, FILICPNL, ResUnit;

type
  TThumbNailFileIconPanel = class(TFileIconPanel)
  public
    FTheBMP : TBitmap;
    { Public declarations }
    procedure Paint; override;                { This allows custom painting  }
    procedure Initialize( PanelX              ,
                          PanelY              ,
                          PanelWidth          ,
                          PanelHeight         ,
                          PanelBevelWidth     ,
                          LabelFontSize         : Integer;
                          PanelColor          ,
                          PanelHighlightColor ,
                          PanelShadowColor    ,
                          LabelTextColor        : TColor;
                          TheFilename         ,
                          LabelFontName         : String;
                          LabelFontStyle        : TFontStyles;
                          ExtraData             : Integer ); override;
  end;

function CreateBitmapThumbNailFromBitmap( SourceBMP: TBitmap;
                                          TargetWidth ,
                                          TargetHeight : Integer ) : TBitmap;
procedure Register;

implementation

type
  File_BitMap = class( TObject )
  public
    Bitmap_Handle    : HBitmap;   { Holds the DIB when done               }
    Width            : Longint;   { Holds the pixel width when done       }
    Height           : Longint;   { Holds the pixel height when done      }
    The_File         : File;      { File variable for internal use        }
    The_Name         : String;    { Holds the file name                   }
    Bits_Handle      : THandle;   { temporary holder for the DIB          }
    Bits_Byte_Size   : Longint;   { temporary holder for the              }
                                  { byte length of the DIB                }
    Error_Status     : Integer;   { code for error condition on the DIB   }

    constructor Create;
    procedure Initialize( The_DIB_Name : String );
    destructor Destroy;
    procedure Get_Bitmap_Data;
    function Get_Bitmap : HBitmap;
    function Load_Bitmap_File : Boolean;
    function Open_DIB : Boolean;
    function Get_Error_Status : Integer;
    procedure Get_DIB_Dimensions( var The_Width  ,
                                      The_Height   : Longint );
  end;

procedure AHIncr; FAR; EXTERNAL 'KERNEL' INDEX 114;

var
  ThumbNailWidth : integer;
  ThumbNailHeight : integer;

function CreateBitmapThumbNailFromBitmap( SourceBMP: TBitmap;
                                          TargetWidth ,
                                          TargetHeight : Integer ) : TBitmap;
var OutputBMP : TBitmap;
    HoldingBMP : TBitmap;
    TotalSourceColsPerOutputCol,
    TotalSourceRowsPerOutputRow,
    Counter_1 ,
    Counter_2 ,
    Counter_3 : Integer;
    CurrentColor : Longint;
    CurrentRowPointer,
    CurrentColPointer,
    BestLineSoFar ,
    TotalColorsInWork : Integer;
    MaxColorsSoFar    : Integer;
begin
  { if source smaller than or equal to thumbnail, stretchdraw and leave }
  if (( SourceBMP.Width <= TargetWidth ) and
      ( SourceBMP.Height <= TargetHeight )) then
  begin
    OutputBMP := TBitmap.Create;
    OutputBMP.Height := TargetHeight;
    OutputBMP.Width := TargetWidth;
    OutputBMP.Canvas.StretchDraw( Rect( 0 , 0 , TargetWidth , TargetHeight ) ,
     SourceBMP );
    CreateBitmapThumbNailFromBitmap := OutputBMP;
    exit;
  end;
  { Otherwise do thumbnail algorithm }
  { Create the interim holding bitmap; it will hold full width but resized # rows }
  HoldingBMP := TBitmap.Create;
  HoldingBMP.Width := SourceBMP.Width;
  HoldingBMP.Height := TargetHeight;
  { Create the final output bitmap; it will hold the resized values in both h & w }
  OutputBMP := TBitmap.Create;
  OutputBMP.Width := TargetWidth;
  OutputBMP.Height := TargetHeight;
  { Determine the total source rows and cols per output row and col }
  TotalSourceRowsPerOutputRow := ( SourceBMP.Height div TargetHeight );
  {if ( SourceBMP.Height mod TargetHeight ) <> 0 then
   Inc( TotalSourceRowsPerOutputRow );}
  TotalSourceColsPerOutputCol := ( SourceBMP.Width div TargetWidth );
  {if ( SourceBMP.Width mod TargetWidth ) <> 0 then
   Inc( TotalSourceColsPerOutputCol );}
  { Start resizing by setting initial row pointer }
  CurrentRowPointer := 0;
  { Loop through desired number of output rows                       }
  { Result will add row per group with highest color density to dest }
  for Counter_1 := 1 to TargetHeight do
  begin
    { Reset colors per line, best cols per line, and best line pointers }
    { Check all the lines in a group against each other }
    TotalColorsInWork := 0;
    MaxColorsSoFar := 0;
    BestLineSoFar := 0;
    for Counter_2 := 1 to TotalSourceRowsPerOutputRow do
    begin
      { Keep moving down the image }
      Inc( CurrentRowPointer );
      if CurrentRowPointer > SourceBMP.Height then break;
      { Start with no color }
      CurrentColor := -1;
      TotalColorsInWork := 0;
      { Actually scan the pixels }
      for Counter_3 := 1 to SourceBMP.Width do
      begin
        { if the current pixel value is different than the stored one }
        If SourceBMP.Canvas.Pixels[ Counter_3 - 1 , CurrentRowPointer - 1 ] <>
         CurrentColor then
        begin
          { Make the new color the stored one }
          CurrentColor := SourceBMP.Canvas.Pixels[ Counter_3 - 1 ,
           CurrentRowPointer - 1 ];
          { Increment total colors in the line }
          Inc( TotalColorsInWork );
        end;
      end;
      { At the end of the line, if there are more colors in the }
      { current line than the previous best line, then }
      if TotalColorsInWork > MaxColorsSoFar then
      begin
        { Set the new max to the current value }
        MaxColorsSoFar := TotalColorsInWork;
        { Set the new best line to the current pointer }
        BestLineSoFar := CurrentRowPointer;
      end;
      { Reset the total colors being checked }
      TotalColorsInWork := 0;
    end;
    MaxColorsSoFar := 0;
    { Once best line is determined, copy all its pixels to the holding bmp }
    for Counter_3 := 1 to SourceBMP.Width do
    begin
      HoldingBMP.Canvas.Pixels[ Counter_3 - 1 , Counter_1 - 1 ] :=
       SourceBMP.Canvas.Pixels[ Counter_3 - 1 , BestLineSoFar - 1 ];
    end;
  end;
  { Then resize by setting initial col pointer }
  CurrentColPointer := 0;
  { Loop through desired number of output cols                       }
  { Result will add col per group with highest color density to dest }
  for Counter_1 := 1 to TargetWidth do
  begin
    { Reset colors per line, best cols per line, and best line pointers }
    TotalColorsInWork := 0;
    MaxColorsSoFar := 0;
    BestLineSoFar := 0;
    { Check all the lines in a group against each other }
    for Counter_2 := 1 to TotalSourceColsPerOutputCol do
    begin
      { Keep moving down the image }
      Inc( CurrentColPointer );
      if CurrentColPointer > HoldingBMP.Width then break;
      { Start with no color }
      CurrentColor := -1;
      { Actually scan the pixels }
      for Counter_3 := 1 to HoldingBMP.Height do
      begin
        { if the current pixel value is different than the stored one }
        If HoldingBMP.Canvas.Pixels[ CurrentColPointer - 1 , Counter_3 - 1 ] <>
         CurrentColor then
        begin
          { Make the new color the stored one }
          CurrentColor := HoldingBMP.Canvas.Pixels[ CurrentColPointer - 1 ,
           Counter_3 - 1 ];
          { Increment total colors in the line }
          Inc( TotalColorsInWork );
        end;
      end;
      { At the end of the line, if there are more colors in the }
      { current line than the previous best line, then }
      if TotalColorsInWork > MaxColorsSoFar then
      begin
        { Set the new max to the current value }
        MaxColorsSoFar := TotalColorsInWork;
        { Set the new best line to the current pointer }
        BestLineSoFar := CurrentColPointer;
      end;
      { Reset the total colors being checked }
      TotalColorsInWork := 0;
    end;
    { Once best line is determined, copy all its pixels to the holding bmp }
    for Counter_3 := 1 to HoldingBMP.Height do
    begin
      OutputBMP.Canvas.Pixels[ Counter_1 - 1 , Counter_3 - 1 ] :=
       HoldingBMP.Canvas.Pixels[ BestLineSoFar - 1 , Counter_3 - 1 ];
    end;
  end;
  { Finally, output the thumbnail image }
  CreateBitmapThumbNailFromBitmap := OutputBMP;
  { And free the working copy }
  HoldingBMP.Free;
end;

{ This creates a file bitmap object }
constructor File_BitMap.Create;
begin
  { call inherited FIRST! }
  inherited Create;
  { Zero out the data elements }
  Bitmap_Handle := 0;
  The_Name := '';
end;

{ This procedure sets up the bitmap filename to load }
procedure File_BitMap.Initialize( The_DIB_Name : String );
begin
  The_Name := The_DIB_Name;
end;

{ This is the destructor procedure }
destructor File_BitMap.Destroy;
begin
  { Assume bitmap handle given to TBitmap and cleared there }
  { call inherited last }
  inherited destroy;
end;

{ This method copies the bitmap bits data from the file into memory. Since }
{ copying cannot cross a segment (64K) boundary, segment arithmetic must   }
{ be done on the fly.  A LongType type was created to simplify this process}
procedure File_BitMap.Get_Bitmap_Data;

type
  LongType = record
  case Word of
    0: ( Ptr  : Pointer );
    1: ( Long : Longint );
    2: ( Lo   : Word;
         Hi   : Word    );
  end;
var
  Count   : Longint;
  Start,
  ToAddr,
  Bits    : LongType;
begin
  Start.Long := 0;
  Bits.Ptr := GlobalLock( Bits_Handle );
  Count := Bits_Byte_Size - Start.Long;
  while Count > 0 do
  begin
    ToAddr.Hi := Bits.Hi + ( Start.Hi * OFS( AHIncr ));
    ToAddr.Lo := Start.Lo;
    if Count > $4000 then Count := $4000;
    BlockRead( The_File , ToAddr.Ptr^ , Count );
    Start.Long := Start.Long + Count;
    Count := Bits_Byte_Size - Start.Long;
  end;
  GlobalUnlock( Bits_Handle );
end;

{ This returns the handle to the stored bitmap }
function File_BitMap.Get_Bitmap : HBitmap;
begin
  Get_Bitmap := Bitmap_Handle;
end;

{ This is the function to call to load a bitmap file of any size }
{ If no errors occur it returns true, otherwise false; use GEC   }
{ (Some portions of this code are copyright Borland Intl, 1990.) }
function File_BitMap.Load_Bitmap_File : Boolean;
var
  Test_Win30_Bitmap : Longint;
  Memory_DC         : HDC;
  The_IO_Result     : Word;
begin
  Error_Status := 0;
  Load_Bitmap_File := false;
  AssignFile( The_File , The_Name );
  {$I-}
  Reset( The_File , 1 );
  Seek( The_File , 14 );
  BlockRead( The_File , Test_Win30_Bitmap , SizeOf( Test_Win30_Bitmap ));
  {$I+}
  The_IO_Result := IOResult;
  If The_IO_Result <> 0 then
  begin
    Error_Status := -1;
  end
  else
  begin
    if Test_Win30_Bitmap = 40 then
    begin
      if Open_DIB then
      begin
        Load_Bitmap_File := true;
      end;
    end
    else
    begin
      Error_Status := -2;
    end;
    CloseFile( The_File );
  end;
end;

{ This does the actual loading of the bitmap's info }
function File_BitMap.Open_DIB : Boolean;
var
  Bit_Count         : Word;
  Size              : Word;
  Long_Width        : Longint;
  DC_Handle         : HDC;
  Bits_Ptr          : Pointer;
  Bitmap_Info       : PBitmapInfo;
  New_Bitmap_Handle : THandle;
  New_Pixel_Width,
  New_Pixel_Height  : Word;
begin
  Open_DIB := true;
  Seek( The_File , 28 );
  BlockRead( The_File , Bit_Count , SizeOf( Bit_Count ));
  if Bit_Count <= 8 then
  begin
    Size := SizeOf( TBitmapInfoHeader ) + (( 1 SHL Bit_Count )
     * SizeOf( TRGBQuad ));
    Bitmap_Info := MemAlloc( Size );
    Seek( The_File , SizeOf( TBitmapFileHeader ));
    BlockRead( The_File , Bitmap_Info^ , Size );
    New_Pixel_Width := Bitmap_Info^.bmiHeader.biWidth;
    New_Pixel_Height := Bitmap_Info^.bmiHeader.biHeight;
    Long_Width := ((( New_Pixel_Width * Bit_Count ) + 31 ) div 32 ) * 4;
    Bitmap_Info^.bmiHeader.biSizeImage := Long_Width * New_Pixel_Height;
    {GlobalCompact( -1 );}
    Bits_Handle := GlobalAlloc( gmem_Moveable or gmem_Zeroinit ,
                                Bitmap_Info^.bmiHeader.biSizeImage );
    Bits_Byte_Size := Bitmap_Info^.bmiHeader.biSizeImage;
    Get_Bitmap_Data;
    DC_Handle := CreateDC( 'Display' , nil , nil , nil );
    Bits_Ptr := GlobalLock( Bits_Handle );
    New_Bitmap_Handle :=
    CreateDIBitmap( DC_Handle , Bitmap_Info^.bmiHeader ,
                    cbm_Init , Bits_Ptr , Bitmap_Info^ , 0 );
    DeleteDC( DC_Handle );
    GlobalUnlock( Bits_Handle );
    GlobalFree( Bits_Handle );
    FreeMem( Bitmap_Info , Size );
    if New_Bitmap_Handle <> 0 then
    begin
      if Bitmap_Handle <> 0 then DeleteObject( Bitmap_Handle );
      Bitmap_Handle := New_Bitmap_Handle;
      Width := New_Pixel_Width;
      Height := New_Pixel_Height;
    end
    else
    begin
      Open_DIB := false;
      Error_Status := -4;
    end;
  end
  else
  begin
    Open_DIB := false;
    Error_Status := -3;
  end;
end;

{ This is an OOP return of the error variable }
function File_BitMap.Get_Error_Status : Integer;
begin
  Get_Error_Status := Error_Status;
end;

{ This is an OOP return of the dimensions of the DIB }
procedure File_BitMap.Get_DIB_Dimensions( var The_Width  ,
                                              The_Height   : Longint );
begin
  The_Width := Width;
  The_Height := Height;
end;

{ Initialization method for FIP                                         }
procedure TThumbNailFileIconPanel.Initialize( PanelX              ,
                                     PanelY              ,
                                     PanelWidth          ,
                                     PanelHeight         ,
                                     PanelBevelWidth     ,
                                     LabelFontSize         : Integer;
                                     PanelColor          ,
                                     PanelHighlightColor ,
                                     PanelShadowColor    ,
                                     LabelTextColor        : TColor;
                                     TheFilename         ,
                                     LabelFontName         : String;
                                     LabelFontStyle        : TFontStyles;
                                     ExtraData             : Integer );

var TheLabelHeight ,             { Holder for label pixel height }
    TheLabelWidth    : Integer;  { Holder for label pixel width  }
    TheOtherPChar    : PChar;    { Windows ASCIIZ string         }
    HolderBMP        : TBitmap;  { Holds working bitmap for tnail}
    HoldName         : String;
    TheBigBMP        : File_Bitmap;
begin
  { Set the basic properties based on imported parameters }
  Left := PanelX;
  Top := PanelY;
  Width := PanelWidth;
  Height := PanelHeight;
  Color := PanelColor;
  BevelWidth := PanelBevelWidth;
  FHighlightColor := PanelHighlightColor;
  FShadowColor := PanelShadowColor;
  FTheName := TheFilename;
  { If the ExtraData field is non-0 then a drive is being sent in }
  if ExtraData <> 0 then
  begin
    GetIconForDrive( ExtraData , FTheIcon );
    { The FileNme property is already set up for the caption; use directly }
    FTheLabel.Caption := TheFilename;
    { Set up the hint for later use (make sure to set ShowHint) }
    Hint := 'Change to ' + TheFileName;
    ShowHint := true;
    { Set up all imported label properties and center it for drawing }
    with FTheLabel do
    begin
      Font.Name := LabelFontName;
      Font.Size := LabelFontSize;
      Font.Style := LabelFontStyle;
      Font.Color := LabelTextColor;
      Canvas.Brush.Color := PanelColor;
      Canvas.Font := Font;
      TheLabelHeight := Canvas.Textheight( Caption ) + 4;
      TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
      Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
      Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
      Top := Top + Round( Self.Height * 0.75 );
      Height := TheLabelHeight;
      Width := TheLabelWidth;
    end;
  end
  else
  begin
    GetIconForFile( FTheName , FTheIcon );
    if FTheName = 'NO FILE' then
    begin
      FTheLabel.Caption := 'NO FILE';
      Hint := 'Not Initialized';
    end
    else
    begin
      { A file or directory has been sent in; use GetIconForFile to obtain an }
      { icon either from the file, its owner, or a RES file default.          }
      GetIconForFile( FTheName , FTheIcon );
      { Check for the Backup caption and set it specially }
      if ExtractfileName( FThename ) = '..' then
      begin
        FTheLabel.Caption := '..';
        Hint := 'Up One Level';
      end
      else
      begin
        if Uppercase( ExtractFileExt( FTheName )) = '.BMP' then
        begin
          TheBigBMP := File_Bitmap.Create;
          TheBigBMP.Initialize( FTheName );
          if TheBigBMP.Load_Bitmap_File then
          begin
            HolderBMP := TBitmap.Create;
            HolderBMP.Handle := TheBigBMP.Get_Bitmap;
            ThumbNailHeight := Round( Height * 0.5 );
            ThumbNailWidth := Round( Width * 0.75 );
            FTheBMP := CreateBitmapThumbNailFromBitmap( HolderBMP , ThumbNailWidth ,
             ThumbNailHeight );
            HolderBMP.Free;
          end
          else
          begin
            MessageDlg( 'Unable to Load ' + FTheName + ' Due to Code ' +
             IntToStr( TheBigBMP.Get_Error_Status ),mtError,[mbok],0);
            FTheBMP := Nil;
          end;
          TheBigBMP.Free;
          FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
          Hint := FTheName;
        end
        else
        begin
          { Otherwise just get the filename for the label caption }
          { And the full path for the hint (used later.)          }
          FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
          Hint := FTheName;
        end;
      end;
    end;
    { Activate showhint so hints are seen }
    ShowHint := true;
    { Set label properties with imported values and center for display }
    with FTheLabel do
    begin
      Font.Name := LabelFontName;
      Font.Size := LabelFontSize;
      Font.Style := LabelFontStyle;
      Font.Color := LabelTextColor;
      Canvas.Brush.Color := PanelColor;
      Canvas.Font := Font;
      TheLabelHeight := Canvas.Textheight( Caption ) + 4;
      TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
      Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
      Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
      Top := Top + Round( Self.Height * 0.75 );
      Height := TheLabelHeight;
      Width := TheLabelWidth;
    end;
  end;
end;

{ Paint method for FIP; overrides normal paint }
procedure TThumbNailFileIconPanel.Paint;
var
  TheOtherRect   : TRect;   { Holds clientrect   }
  TopColor     ,            { Holds bright color }
  BottomColor    : TColor;  { Holds dark color   }

{ These methods are from Borland Intl., copyright 1995 }
procedure Frame3D(    Canvas       : TCanvas;
                  var TheRect      : TRect;
                      TopColor   ,
                      BottomColor  : TColor;
                      Width        : Integer );

procedure DoRect;
var
  TopRight, BottomLeft: TPoint;
begin
  with Canvas, TheRect do
  begin
    TopRight.X := Right;
    TopRight.Y := Top;
    BottomLeft.X := Left;
    BottomLeft.Y := Bottom;
    Pen.Color := TopColor;
    PolyLine([BottomLeft, TopLeft, TopRight]);
    Pen.Color := BottomColor;
    Dec(BottomLeft.X);
    PolyLine([TopRight, BottomRight, BottomLeft]);
  end;
end;

begin
  Canvas.Pen.Width := 1;
  Dec(TheRect.Bottom); Dec(TheRect.Right);
  while Width > 0 do
  begin
    Dec(Width);
    DoRect;
    InflateRect(TheRect, -1, -1);
  end;
  Inc(TheRect.Bottom); Inc(TheRect.Right);
end;

procedure AdjustColors(Bevel: TPanelBevel);
begin
  TopColor := FHighlightColor;
  if Bevel = bvLowered then TopColor := FShadowColor;
  BottomColor := FShadowColor;
  if Bevel = bvLowered then BottomColor := FHighlightColor;
end;

{ Custom code begins here }
begin
  if OldName <> TheName then InitTheFIP;
  if (( OldWidth <> Width ) or ( OldHeight <> Height )) then InitTheFIP;
  { Get the rectangle of the control with API/method call }
  TheOtherRect := GetClientRect;
  { draw basic rectangle with basic color }
  with Canvas do
  begin
    Brush.Color := Color;
    FillRect(TheOtherRect);
  end;
  { Set up for top "icon" frame  and draw it with frame3d }
  TheOtherRect.Right := Width;
  TheOtherRect.Bottom := Round( Height * 0.75 ) - 6 ;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  { Do the same for the lower "label" frame }
  TheOtherRect.Top := Round( Height * 0.75 ) - 5;
  TheOtherRect.Left := 0;
  TheOtherRect.Bottom := Height;
  TheOtherRect.Right := Width;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  if Assigned( FTheBMP ) then
  begin
    {Canvas.BrushCopy( Rect( (( Width - ThumbNailWidth ) div 2 ) + 2 ,
                            ( (( Round( Height * 0.75 ) - 6 ) - ThumbNailHeight ) div 2 ) + 1 ,
                            ThumbNailWidth , ThumbNailHeight ) ,
                      FTheBMP ,
                      Rect( 0 , 0 , ThumbNailWidth , ThumbNailHeight ) , GlobalTransparentColor );}
    Canvas.Draw( Round( Width * 0.125 ) + 1 ,
                 Round( Height * 0.125 ) + 1, FTheBMP );
  end
  else
  begin
    { Then draw the icon using canvas draw method }
    Canvas.Draw( (( Width - 32 ) div 2 ) + 1 ,
    ((( Round( Height * 0.75 ) - 6 ) - 32 ) div 2 ) + 1 , FTheIcon );
  end;
end;

procedure Register;
begin
  RegisterComponents('Widgets', [TThumbNailFileIconPanel]);
end;

end.